home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
Dev
/
Oberon
/
source
/
EAGUI
/
OAExample.mod
< prev
next >
Wrap
Text File
|
1995-06-29
|
13KB
|
420 lines
(*************************************************************************
$RCSfile: OAExample.mod $
Description: Oberon-2 port of the EAGUI example.c
Created by: fjc (Frank Copeland)
$Revision: 1.1 $
$Author: fjc $
$Date: 1995/06/29 18:48:07 $
Copyright © 1995, Frank Copeland.
This file is part of Oberon-A.
See Oberon-A.doc for conditions of use and distribution.
*************************************************************************)
(*
* RCSfile: Example.c,v
* Author: marcel
* Revision: 3.2
* Date: 1994/12/01 07:04:30
* Locker: marcel
* State: Exp
*
* Description: This is an example of how to use EAGUI. In fact it is the
* complete version of the example used in the tutorial[2]. It can be
* compiled under SAS/C 6.51. It should be fairly trivial to modify
* this example to create any window you want[1]. Please note that the
* contents of the gadgets aren't saved, so after a resize, everything
* is lost. Under V39 it is very easy to get and set these attributes
* (with GT_GetGadgetAttrs() and GT_SetGadgetAttrs()), and although
* it's a bit more difficult under V37, it can be done there too (it's
* something you'll have to do anyway).
*
* [1] If you want to create a new window, it is enough to specify a new
* tree of objects. The only other thing you might want to change is
* the fact that the window in this example can only be resized in
* horizontal direction. If you change the last argument of the
* WindowLimits() call to "~0" that's fixed too.
*
* [2] In fact, it is a slightly enhanced example, which shows a little bit
* more.
*)
<* STANDARD- *>
MODULE OAExample;
IMPORT
SYS := SYSTEM, Errors, Kernel, s := Sets, e := Exec, u := Utility,
gfx := Graphics, i := Intuition, gt := GadTools, df := DiskFont,
ea := EAGUI, eam := EAGUI_Macros, lbl := EALabels;
(*------------------------------------*)
CONST
VersionTag = "$VER: OAExample 1.1 (18.4.95)";
VersionStr = "OAExample 1.1 (18.4.95)\n";
CopyrightStr = "Copyright © 1995 Frank Copeland";
(*------------------------------------*)
VAR
winobj_ptr * : ea.OPTR;
okobj_ptr * : ea.OPTR;
cancelobj_ptr * : ea.OPTR;
hgroupobj_ptr * : ea.OPTR;
win_ptr * : i.WindowPtr;
scr_ptr * : i.ScreenPtr;
gadlist_ptr * : i.GadgetPtr;
stringgadget_ptr * : i.GadgetPtr;
visualinfo_ptr * : gt.VisualInfo;
drawinfo_ptr * : i.DrawInfoPtr;
tf_ptr * : gfx.TextFontPtr;
textattr * : gfx.TextAttr;
relhook * : u.Hook;
imsg * : i.IntuiMessage;
label * : lbl.Label;
(*------------------------------------*)
(* same size relation *)
PROCEDURE* rel_samesize
( hook_ptr : u.HookPtr;
list_ptr : e.ListPtr;
msg_ptr : e.APTR )
: e.ULONG;
VAR
ro_ptr : ea.RelationObjectPtr;
minx, miny, x, y, ignore : e.ULONG;
BEGIN (* rel_samesize *)
minx := 0;
miny := 0;
(* examine the list of objects that are affected by the relation *)
ro_ptr := SYS.VAL (ea.RelationObjectPtr, list_ptr.head);
WHILE ro_ptr.node.succ # NIL DO
ignore := ea.GetAttrs ( ro_ptr.object_ptr,
ea.MinWidth, SYS.ADR (x),
ea.MinHeight, SYS.ADR (y),
u.done );
(* find the maximum values of the minimum sizes *)
IF x > minx THEN minx := x END;
IF y > miny THEN miny := y END;
ro_ptr := SYS.VAL (ea.RelationObjectPtr, ro_ptr.node.succ)
END;
(* set all objects to the newly found minimum sizes *)
ro_ptr := SYS.VAL (ea.RelationObjectPtr, list_ptr.head);
WHILE ro_ptr.node.succ # NIL DO
ignore := ea.SetAttrs ( ro_ptr.object_ptr,
ea.MinWidth, minx,
ea.MinHeight, miny,
u.done );
ro_ptr := SYS.VAL (ea.RelationObjectPtr, ro_ptr.node.succ)
END;
RETURN 0
END rel_samesize;
(*------------------------------------*)
PROCEDURE resizewindow;
VAR
bl, br, bt, bb, ignore : LONGINT;
BEGIN (* resizewindow *)
(* if necessary, remove the gadget list from the window, and clean it
* up
*)
IF gadlist_ptr # NIL THEN
ignore := i.RemoveGList ( win_ptr, gadlist_ptr, -1 );
ea.FreeGadgetList (winobj_ptr, gadlist_ptr);
gadlist_ptr := NIL;
END;
ignore := ea.GetAttrs (winobj_ptr,
ea.BorderLeft, SYS.ADR (bl),
ea.BorderRight, SYS.ADR (br),
ea.BorderTop, SYS.ADR (bt),
ea.BorderBottom, SYS.ADR (bb),
u.done );
ignore := ea.SetAttrs (winobj_ptr,
ea.Width, win_ptr.width -
win_ptr.borderLeft -
win_ptr.borderRight -
bl -
br,
ea.Height, win_ptr.height -
win_ptr.borderTop -
win_ptr.borderBottom -
bt -
bb,
ea.Left, win_ptr.borderLeft,
ea.Top, win_ptr.borderTop,
u.done );
ea.LayoutObjects (winobj_ptr);
IF ea.CreateGadgetList ( winobj_ptr, gadlist_ptr, visualinfo_ptr,
drawinfo_ptr )
# ea.ERROR_OK
THEN
HALT (36)
END;
gfx.EraseRect (win_ptr.rPort,
win_ptr.borderLeft,
win_ptr.borderTop,
win_ptr.width - win_ptr.borderRight - 1,
win_ptr.height - win_ptr.borderBottom - 1);
i.RefreshWindowFrame (win_ptr);
ignore := i.AddGList (win_ptr, gadlist_ptr, -1, -1, NIL);
i.RefreshGList (gadlist_ptr, win_ptr, NIL, -1);
gt.RefreshWindow (win_ptr, NIL);
(* finally, we render the imagery, if there is any *)
ea.RenderObjects (winobj_ptr, win_ptr.rPort);
END resizewindow;
(*------------------------------------*)
PROCEDURE* Cleanup (VAR rc : LONGINT);
VAR ignore : LONGINT;
BEGIN (* Cleanup *)
IF gadlist_ptr # NIL THEN
ignore := i.RemoveGList (win_ptr, gadlist_ptr, -1);
ea.FreeGadgetList (winobj_ptr, gadlist_ptr);
gadlist_ptr := NIL
END;
IF win_ptr # NIL THEN
i.CloseWindow (win_ptr);
win_ptr := NIL;
END;
IF drawinfo_ptr # NIL THEN
i.FreeScreenDrawInfo (scr_ptr, drawinfo_ptr);
drawinfo_ptr := NIL;
END;
IF visualinfo_ptr # NIL THEN
gt.FreeVisualInfo (visualinfo_ptr);
visualinfo_ptr := NIL;
END;
IF scr_ptr # NIL THEN
i.UnlockPubScreen (e.NILSTR, scr_ptr);
scr_ptr := NIL;
END;
IF winobj_ptr # NIL THEN
ea.DisposeObject (winobj_ptr);
winobj_ptr := NIL;
END;
IF tf_ptr # NIL THEN
gfx.CloseFont (tf_ptr);
tf_ptr := NIL;
END;
END Cleanup;
(*------------------------------------*)
PROCEDURE Init ();
VAR
w, h, bl, br, bt, bb, ignore : LONGINT;
w_ptr, h_ptr, bl_ptr, br_ptr, bt_ptr, bb_ptr : SYS.ADDRESS;
BEGIN (* Init *)
Kernel.SetCleanup (Cleanup);
textattr.name := SYS.ADR ("helvetica.font");
textattr.ySize := 15;
textattr.style := gfx.normal;
textattr.flags := {gfx.diskFont};
(* open the font *)
tf_ptr := df.OpenDiskFont (textattr);
IF tf_ptr = NIL THEN HALT (30) END;
(* initialize the relation *)
u.InitHook (SYS.ADR (relhook), SYS.VAL (u.HookFunc, rel_samesize));
(*
(* initialize textfield hooks *)
u.InitHook (SYS.ADR (tfminsizehook), SYS.VAL (u.HookFunc, lbl.MinSize));
u.InitHook (SYS.ADR (tfrenderhook), SYS.VAL (u.HookFunc, lbl.Render));
*)
(* set up some defaults for all objects *)
ignore := ea.SetAttr (NIL, ea.DefGTTextAttr, SYS.ADR (textattr));
(* now we can build the object tree *)
okobj_ptr := eam.GTButton (SYS.ADR ("Ok"), u.done);
cancelobj_ptr := eam.GTButton(SYS.ADR ("Cancel"), u.done);
hgroupobj_ptr := eam.HGroup (
ea.BorderTop, 4,
ea.Child, okobj_ptr,
ea.Child, eam.EmptyBox (1, u.done),
ea.Child, cancelobj_ptr,
u.done );
winobj_ptr := eam.VGroup (
ea.BorderLeft, 4,
ea.BorderRight, 4,
ea.BorderTop, 4,
ea.BorderBottom, 4,
ea.Child, lbl.NewLabel ( label,
ea.BorderBottom, 4,
u.done ),
ea.Child, eam.GTString ( NIL,
ea.InstanceAddress, SYS.ADR (stringgadget_ptr),
ea.MinWidth, 20, (* Fixes a bug in the GadTools library, which
* renders the full contents of the gadget, if
* it is very small, and you're using a fixed-
* width font. Originally reported by Roy van
* der Woning.
*)
u.done ),
ea.Child, hgroupobj_ptr,
u.done );
IF winobj_ptr = NIL THEN HALT (31) END;
ignore := ea.NewRelation ( hgroupobj_ptr, SYS.ADR (relhook),
ea.Object, okobj_ptr,
ea.Object, cancelobj_ptr,
u.done );
(* lock the screen *)
scr_ptr := i.LockPubScreen (e.NILSTR);
IF scr_ptr = NIL THEN HALT (32) END;
(* get VisualInfo and DrawInfo *)
visualinfo_ptr := gt.GetVisualInfo (scr_ptr, u.done);
IF visualinfo_ptr = NIL THEN HALT (33) END;
drawinfo_ptr := i.GetScreenDrawInfo (scr_ptr);
IF drawinfo_ptr = NIL THEN HALT (34) END;
(* fill in the label structure *)
lbl.InitLabel ( label,
SYS.ADR ("Enter a string here:"),
SYS.ADR (textattr),
gfx.jam1,
{lbl.AlignTop, lbl.ShadowText},
drawinfo_ptr );
(* obtain the minimum dimensions of every object in the tree *)
ea.GetMinSizes (winobj_ptr);
(* get some attributes *)
w_ptr := SYS.ADR (w); h_ptr := SYS.ADR (h);
bl_ptr := SYS.ADR (bl); br_ptr := SYS.ADR (br);
bt_ptr := SYS.ADR (bt); bb_ptr := SYS.ADR (bb);
ignore := ea.GetAttrs ( winobj_ptr,
ea.MinWidth, w_ptr,
ea.MinHeight, h_ptr,
ea.BorderLeft, bl_ptr,
ea.BorderRight, br_ptr,
ea.BorderTop, bt_ptr,
ea.BorderBottom, bb_ptr,
u.done );
(* open the window *)
win_ptr := i.OpenWindowTagsA ( NIL,
i.waTitle, SYS.ADR ("EAGUI Example"),
i.waFlags, { i.windowDrag, i.windowDepth, i.windowClose,
i.windowSizing, i.sizeBBottom, i.activate },
i.waIDCMP, { i.closeWindow, i.refreshWindow, i.newSize }
+ gt.buttonIDCMP + gt.stringIDCMP,
i.waInnerHeight, h + bt + bb,
i.waInnerWidth, (w + bl + br) * 2,
u.done );
IF win_ptr = NIL THEN HALT (35) END;
(* set the window limits *)
IF i.WindowLimits ( win_ptr,
w + win_ptr.borderLeft + win_ptr.borderRight + bl + br,
h + win_ptr.borderTop + win_ptr.borderBottom + bt + bb,
-1,
h + win_ptr.borderTop + win_ptr.borderBottom + bt + bb )
THEN END;
(* create the gadgets and add them to the window *)
resizewindow();
END Init;
(*------------------------------------*)
PROCEDURE handlemsgs () : LONGINT;
VAR
imsg_ptr : i.IntuiMessagePtr;
rc : e.ULONG;
BEGIN (* handlemsgs *)
LOOP
imsg_ptr := gt.GetIMsg (win_ptr.userPort);
IF imsg_ptr = NIL THEN EXIT END;
imsg := imsg_ptr^;
gt.ReplyIMsg (imsg_ptr);
IF imsg.class = {i.refreshWindow} THEN
gt.BeginRefresh (win_ptr);
gt.EndRefresh (win_ptr, i.LTRUE)
ELSIF imsg.class = {i.closeWindow} THEN
rc := 10
ELSIF imsg.class = {i.newSize} THEN
resizewindow();
(* Just for fun, we put a string in the string gadget after each
* resize. This demonstrates how to use the EA_InstanceAddress
* tag to obtain pointers to gadgets, which you can use to modify
* the gadgets directly.
*)
gt.SetGadgetAttrs (
stringgadget_ptr^, win_ptr, NIL,
gt.stString, SYS.ADR ("Ah, a size change! How nice."),
u.done )
END
END; (* LOOP *)
RETURN rc
END handlemsgs;
(*------------------------------------*)
PROCEDURE Main ();
VAR
idcmpmask, signals : s.SET32;
done : BOOLEAN;
BEGIN (* Main *)
done := FALSE;
(* event handling loop *)
idcmpmask := {win_ptr.userPort.sigBit};
WHILE ~done DO
signals := e.Wait (idcmpmask);
IF (signals * idcmpmask) # {} THEN
IF handlemsgs() # 0 THEN done := TRUE END
END
END
END Main;
(*------------------------------------*)
BEGIN (* OAExample *)
Errors.Init;
Init;
Main
END OAExample.